perm filename FIXUP[F75,JMC] blob sn#188583 filedate 1975-11-26 generic text, type T, neo UTF8

(DEFPROP ALLFNS
 (NIL COUNT COUNTA FIXUP COMMON COMA COMB COMC)
VALUE)

(DEFPROP COUNT
 (LAMBDA (E1 E2) (COND ((EQUAL E1 E2) 1) ((ATOM E2) 0) (T (COUNTA E1 (CDR E2)))))
EXPR)

(DEFPROP COUNTA
 (LAMBDA (E U) (COND ((NULL U) 0) (T (PLUS (COUNT E (CAR U)) (COUNTA E (CDR U))))))
EXPR)

(DEFPROP FIXUP
 (LAMBDA(E)
  ((LAMBDA(Z)
    (COND ((NULL Z) E)
	  (T ((LAMBDA (W) (LIST (LIST (QUOTE LAMBDA) (LIST W) (FIXUP (SUBST W Z E))) Z)) (GENSYM)))))
   (COMMON E)))
EXPR)

(DEFPROP COMMON
 (LAMBDA (E) ((LAMBDA (W) (COND ((NULL W) NIL) (T (COMC (CAR W) E (CDR W))))) (COMA E E 1)))
EXPR)

(DEFPROP COMA
 (LAMBDA (E1 E2 N) ((LAMBDA (W) (COND ((GREATERP W N) (CONS E1 W)) (T (COMB (CDR E1) E2 N)))) (COUNT E1 E2)))
EXPR)

(DEFPROP COMB
 (LAMBDA(U E N)
  (COND	((OR (NULL U) (ATOM (CAR U))) NIL)
	(T ((LAMBDA (Z) (COND ((NULL Z) (COMB (CDR U) E N)) (T Z))) (COMA (CAR U) E N)))))
EXPR)

(DEFPROP COMC
 (LAMBDA (E1 E N) ((LAMBDA (W) (COND ((NULL W) E1) (T (COMC (CAR W) E (CDR W))))) (COMA E1 E (ADD1 N))))
EXPR)